home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
tptc16.zip
/
TPCSTMT.INC
< prev
next >
Wrap
Text File
|
1993-01-04
|
16KB
|
854 lines
(*
* TPTC - Turbo Pascal to C translator
*
* (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
*
*)
(********************************************************************)
(*
* control statement processors
* for, while, repeat, with, idents
*
* all expect tok to be keyword
* all exit at end of statement with ltok as ; or end
*
*)
procedure pfor;
var
up: boolean;
id: string80;
low,high: string80;
begin
write(ofd[level],'for (');
gettok; {consume the FOR}
id := plvalue;
gettok; {consume the :=}
low := pexpr;
if tok = 'TO' then
up := true
else
if tok = 'DOWNTO' then
up := false
else
begin
syntax('TO or DOWNTO expected (pfor)');
exit;
end;
gettok;
high := pexpr;
if up then
write(ofd[level],id,' = ',low,'; ',id,' <= ',high,'; ',id,'++) ')
else
write(ofd[level],id,' = ',low,'; ',id,' >= ',high,'; ',id,'--) ');
gettok; {consume the DO}
pstatement;
end;
(********************************************************************)
procedure pwhile;
var
cond: string255;
begin
gettok; {consume the WHILE}
cond := pexpr;
write(ofd[level],'while (',cond,') ');
gettok; {consume the DO}
pstatement;
end;
(********************************************************************)
procedure pwith;
var
prefix: string80;
begin
write(ofd[level],'/* with ');
gettok; {consume the DO}
prefix := plvalue;
write(ofd[level],prefix,' DO */ ');
gettok; {consume the DO}
pstatement;
write(ofd[level],' /* end with */');
newline;
end;
(********************************************************************)
procedure prepeat;
var
cond: string255;
begin
write(ofd[level],'do { ');
gettok;
while tok <> 'UNTIL' do
begin
pstatement;
if tok = ';' then
begin
puttok;
gettok;
end;
end;
gettok;
cond := pexpr;
write(ofd[level],'} while (!(', cond, ')) ');
end;
(********************************************************************)
procedure pcase;
var
ex: string255;
i: integer;
c: char;
begin
gettok;
ex := pexpr;
write(ofd[level],'switch (',ex,') {');
gettok; {consume the OF}
while (tok <> '}') and (tok <> 'ELSE') do
begin
repeat
if tok = ',' then
gettok;
if tok = '..' then
begin
i := atoi(ex);
if i = 0 then
c := ex[2];
gettok;
ex := pexpr;
if i=0 then
for c := succ(c) to ex[2] do
begin
newline;
write(ofd[level],'case ''',c,''': ');
end
else
for i := succ(i) to atoi(ex) do
begin
newline;
write(ofd[level],'case ',i,': ');
end;
end
else
begin
ex := pexpr;
newline;
write(ofd[level],'case ',ex,': ');
end;
until tok = ':';
gettok;
pstatement;
write(ofd[level],'break; ');
newline;
if tok = ';' then
gettok;
end;
if tok = 'ELSE' then
begin
newline;
write(ofd[level],'default: ');
gettok; {consume the else}
while tok <> '}' do
begin
pstatement;
if tok = ';' then
gettok;
end;
end;
puttok;
gettok;
if tok = ';' then
gettok;
end;
(********************************************************************)
procedure pif;
var
cond: string255;
begin
gettok; {consume the IF}
cond := pexpr;
write(ofd[level],'if (', cond, ') ');
gettok; {consume the THEN}
pstatement;
if tok = 'ELSE' then
begin
write(ofd[level],'else ');
gettok;
if tok <> '}' then
pstatement;
end;
end;
(********************************************************************)
procedure pexit;
begin
write(ofd[level],'return;');
gettok;
if tok = ';' then
gettok;
end;
(********************************************************************)
procedure pgoto;
var
ex: anystring;
begin
gettok; {consume the goto}
if toktype = number then
ltok := 'label_' + ltok; {modify numeric labels}
write(ofd[level],'goto ',ltok,';');
gettok; {consume the label}
if tok = ';' then
gettok;
end;
(********************************************************************)
procedure phalt;
var
ex: anystring;
begin
gettok;
if tok = '(' then
begin
gettok;
ex := pexpr;
gettok;
end
else
ex := '0'; {default exit expression}
write(ofd[level],'exit(',ex,')',';');
if tok = ';' then
gettok;
end;
(********************************************************************)
procedure pread;
var
ctl: anystring;
func: anystring;
ex: paramlist;
ty: paramlist;
w: anystring;
n: anystring;
ln: boolean;
i: integer;
sym: symptr;
begin
nospace := true; {don't copy source whitespace to output during
this processing. this prevents spaces from
getting moved around}
ln := tok = 'READLN';
nospace := true;
func := 'scanv(';
gettok; {consume the write}
if tok = '(' then
begin
gettok;
if ltok = '[' then {check for MT+ [addr(name)], form}
begin
gettok; {consume the '[' }
if tok = ']' then
func := 'scanf('
else
begin
gettok; {consume the ADDR}
gettok; {consume the '(' }
func := 'fiscanf(' + usetok + ',';
gettok; {consume the ')'}
end;
gettok; {consume the ']'}
if tok = ',' then
gettok;
end
else
begin
sym := locatesym(ltok); {check for file variables}
if sym <> nil then
begin
if sym^.symtype = s_file then
begin
func := 'fscanv(' + usetok + ',';
if tok = ',' then
gettok;
end;
end;
end;
ctl := '';
ex.n := 0;
while tok <> ')' do
begin
inc(ex.n);
ex.id[ex.n] := pexpr;
ty.id[ex.n] := exprtype(ex.id[ex.n]);
ctl := ctl + '%'+ty.id[ex.n];
if tok = ',' then
gettok;
end;
gettok; {consume the )}
if ctl = '%s' then
ctl := '#';
if ln then
ctl := ctl + '\n';
if func[1] <> 'f' then
func := 'f' + func + 'stdin,';
write(ofd[level],func,'"',ctl,'"');
for i := 1 to ex.n do
if ty.id[i] <> 's' then
write(ofd[level],',&',ex.id[i])
else
write(ofd[level],',',ex.id[i]);
write(ofd[level],')');
end
else {otherwise there is no param list}
if ln then
write(ofd[level],'scanf("\n")');
nospace := false;
if tok = ';' then
begin
puttok;
gettok;
end
else
begin
write(ofd[level],'; ');
newline;
end;
end;
(********************************************************************)
procedure pwrite;
var
ctl: anystring;
func: anystring;
ex: paramlist;
w: anystring;
n: anystring;
p: string255;
ln: boolean;
ty: string[2];
i: integer;
begin
nospace := true; {don't copy source whitespace to output during
this processing. this prevents spaces from
getting moved around}
ln := tok = 'WRITELN';
nospace := true;
func := 'printf(';
gettok; {consume the write}
if tok = '(' then
begin
gettok; {consume the (}
ctl := '';
ex.n := 0;
while tok <> ')' do
begin
p := pexpr;
if (ex.n = 0) and (curtype = s_file) then
begin
func := 'fprintf(' + p + ',';
end
else
begin
inc(ex.n);
ex.id[ex.n] := p;
ty := exprtype(p);
if ty = 'D' then
ty := 'ld';
w := '';
n := '';
if tok = ':' then
begin
gettok;
w := pexpr;
if tok = ':' then
begin
gettok;
n := pexpr;
ctl := ctl + '%'+w+'.'+n+'f';
end
else
ctl := ctl + '%'+w+ty;
end
else
begin
{pass literals into the control string}
if (p[1] = '"') or (p[1] = '''') then
begin
ctl := ctl + copy(p,2,length(p)-2);
dec(ex.n);
end
{otherwise put in the control string for this param}
else
ctl := ctl + '%'+ty;
end;
end;
if tok = ',' then
gettok;
end;
gettok; {consume the )}
if ln then
ctl := ctl + '\n';
write(ofd[level],func,'"',ctl,'"');
for i := 1 to ex.n do
write(ofd[level],',',ex.id[i]);
write(ofd[level],')');
end
else {otherwise there is no param list}
if ln then
write(ofd[level],'printf("\n")');
nospace := false;
if tok = ';' then
begin
puttok;
gettok;
end
else
begin
write(ofd[level],'; ');
newline;
end;
end;
(********************************************************************)
procedure pnew;
var
lv: string255;
begin
gettok; {consume the new}
gettok; {consume the (}
lv := plvalue;
gettok; {consume the )}
write(ofd[level],lv,' = malloc(sizeof(*',lv,'));');
if tok = ';' then
gettok;
end;
(********************************************************************)
procedure pport(kw: string255);
{translate port/portw/mem/memw}
var
lv: string255;
begin
lv := kw + '(';
gettok; {consume the keyword}
gettok; {consume the [ }
repeat
lv := lv + pexpr;
if tok = ':' then
begin
gettok;
lv := lv + ',';
end;
until tok = ']';
gettok; {consume the ] }
if tok = ':=' then
begin
gettok; {consume :=, assignment statement}
lv := lv + ',' + pexpr;
end;
write(ofd[level],lv,');');
if tok = ';' then
gettok;
end;
(********************************************************************)
procedure pinline;
{translate inline statements}
var
lv: string255;
begin
gettok; {consume the keyword}
lv := '';
while tok <> ')' do
begin
gettok;
if (tok = '/') or (tok = ')') then
begin
writeln(ofd[level],' asm db ',lv,';');
lv := '';
end
else
lv := lv + ltok + ' ';
end;
gettok; {consume the ) }
if tok = ';' then
gettok;
end;
(********************************************************************)
procedure pident;
{parse statements starting with an identifier; these are either
assignment statements, function calls, return-value assignments,
or label identifiers}
var
ex: string255;
lv: string255;
lvt,ext: char;
begin
nospace := true; {don't copy source whitespace to output during
this processing. this prevents spaces from
getting moved around}
lv := plvalue;
if tok = ':=' then
begin
gettok; {consume :=, assignment statement}
ex := pexpr;
if iscall(lv) then
write(ofd[level],'return ',ex)
else
begin
lvt := exprtype(lv);
ext := exprtype(ex);
if copy(ex,1,5) = 'scat(' then
write(ofd[level],'sbld(', lv,',' , copy(ex,6,255))
else
if copy(ex,1,5) = 'scat(' then
write(ofd[level],'sbld(', lv,',' , copy(ex,6,255))
else
if lvt = 's' then
if ext = 's' then
write(ofd[level],'strcpy(',lv,', ',ex,')')
else
write(ofd[level],'sbld(',lv,',"%',ext,'",',ex,')')
else
if lvt = 'c' then
if ext = 's' then
write(ofd[level],lv,' = first(',ex,')')
else
write(ofd[level],lv,' = ',ex)
else
write(ofd[level],lv,' = ',ex);
end;
end
else
if tok = ':' then
begin
writeln(ofd[level]);
write(ofd[level],lv,': ');
gettok; {label identifier}
if tok = ';' then
gettok;
exit;
end
else
if iscall(lv) then
write(ofd[level],lv)
else
write(ofd[level],lv,'()');
nospace := false;
if tok = ';' then
begin
puttok;
gettok;
end
else
begin
write(ofd[level],'; ');
newline;
end;
end;
(********************************************************************)
procedure pnumlabel;
{parse statements starting with an number; these must be
numeric labels}
begin
writeln(ofd[level]);
write(ofd[level],'label_',tok,': ');
gettok; {consume the number}
if tok <> ':' then
begin
syntax('":" expected (pnumlabel)');
exit;
end;
gettok; {consume the :}
end;
(********************************************************************)
(*
* process single statement
*
* expects tok to be first token of statement
* processes nested blocks
* exits with tok as end of statement
*
*)
procedure pstatement;
begin
if tok = ';' then
begin
write(ofd[level],'; ');
gettok;
end
else
if tok = '{' then
pblock
else
if tok = 'FOR' then
pfor
else
if tok = 'WHILE' then
pwhile
else
if tok = 'WITH' then
pwith
else
if tok = 'REPEAT' then
prepeat
else
if tok = 'CASE' then
pcase
else
if tok = 'IF' then
pif
else
if tok = 'EXIT' then
pexit
else
if tok = 'GOTO' then
pgoto
else
if tok = 'HALT' then
phalt
else
if tok = 'WRITE' then
pwrite
else
if tok = 'WRITELN' then
pwrite
else
if tok = 'READ' then
pread
else
if tok = 'READLN' then
pread
else
if tok = 'NEW' then
pnew
else
if tok = 'PORT' then
pport('outportb')
else
if tok = 'PORTW' then
pport('outport')
else
if tok = 'MEM' then
pport('pokeb')
else
if tok = 'MEMW' then
pport('poke')
else
if tok = 'INLINE' then
pinline
else
if toktype = number then
pnumlabel
else
pident;
end;
(********************************************************************)
(*
* process begin...end blocks
*
* expects tok to be begin
* exits with tok = end
*
*)
procedure pblock;
begin
write(ofd[level],'{ ');
gettok; {get first token of first statement}
while tok <> '}' do
begin
pstatement; {process the statement}
if tok = ';' then
begin
puttok;
gettok; {get first token of next statement}
end;
end;
puttok;
gettok;
if tok = ';' then
gettok;
end;
